home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / dtm / dtm.c < prev    next >
C/C++ Source or Header  |  1991-06-18  |  47KB  |  1,704 lines
  1. /*
  2.    File: dtm.c
  3. */
  4. #include <strings.h>
  5. #include <stdio.h>
  6. #include <tmc.h>
  7. #include <cvr.h>
  8. #include "dtmconst.h"
  9. #include "tmcode.h"
  10. #include "utils.h"
  11. #include "codestorage.h"
  12. #include "typecache.h"
  13.  
  14. /* command line flags */
  15. static int showorig = TRUE;
  16. static int symtabtr = FALSE;
  17. static int stat = FALSE;
  18. static int utm = 0;            /* unit delay model */
  19. static int eich = 0;            /* use eichelberger values: 0,x,1 */
  20. static int implicit = 0;        /* use implicit clock signals */
  21.  
  22. /* common variables */
  23. #define infile stdin
  24. #define outfile stdout
  25. FILE *tracestream = stderr;
  26.  
  27. /* fields of definition to be monitored */
  28. typ intyp, outtyp;
  29. formcon deffc;
  30. val defval;
  31.  
  32. char **cnames;
  33. typ *ctypes;
  34. int firstsrcnr;
  35. int nrofinputs;
  36.  
  37. /* names of procs and locals */
  38. #define proclowend 100
  39. int procnr = proclowend;
  40. int localnr = 0;
  41.  
  42. /*
  43.    Table of debugging flags plus associated information.
  44.    Table is ended by an entry with flagchar '\0'
  45. */
  46. static dbflag flagtab[] =
  47.     {{ 's', &stat, "statistics" },
  48.      { 't', &symtabtr, "symbol table tracing" },
  49.      { '\0', (int *)0, "" },
  50.     };
  51.  
  52. static void code_generic_zport ();
  53. static void code_generic_uport ();
  54. static void code_generic_mport ();
  55. static void code_dff ();
  56. static void code_jkff ();
  57. static void code_tff ();
  58. static void code_tlatch ();
  59. static void code_tglatch ();
  60.  
  61. typedef struct
  62.     { char *atomname;
  63.       void (*atomcode) ();
  64.       char *codedname;
  65.     } init_atom;
  66.  
  67. init_atom known_atoms [] =
  68.     {{ "zero",  code_generic_zport, "zero" },
  69.      { "one",   code_generic_zport, "one" },
  70.      { "undef", code_generic_zport, "undef" },
  71.      { "init",  code_generic_zport, "init" },
  72.      { "buf",   code_generic_uport, "buf" },
  73.      { "not",   code_generic_uport, "not" },
  74.      { "nand",  code_generic_mport, "nand2" },
  75.      { "nand2", code_generic_mport, "nand2" },
  76.      { "nand3", code_generic_mport, "nand3" },
  77.      { "nand4", code_generic_mport, "nand4" },
  78.      { "nand5", code_generic_mport, "nand5" },
  79.      { "and",   code_generic_mport, "and2" },
  80.      { "and2",  code_generic_mport, "and2" },
  81.      { "and3",  code_generic_mport, "and3" },
  82.      { "and4",  code_generic_mport, "and4" },
  83.      { "and5",  code_generic_mport, "and5" },
  84.      { "nor",   code_generic_mport, "nor2" },
  85.      { "nor2",  code_generic_mport, "nor2" },
  86.      { "nor3",  code_generic_mport, "nor3" },
  87.      { "nor4",  code_generic_mport, "nor4" },
  88.      { "nor5",  code_generic_mport, "nor5" },
  89.      { "or",    code_generic_mport, "or2" },
  90.      { "or2",   code_generic_mport, "or2" },
  91.      { "or3",   code_generic_mport, "or3" },
  92.      { "or4",   code_generic_mport, "or4" },
  93.      { "or5",   code_generic_mport, "or5" },
  94.      { "xor",   code_generic_mport, "xor2" },
  95.      { "xor2",  code_generic_mport, "xor2" },
  96.      { "ornot", code_generic_mport, "nand2" },
  97.      { "dff",   code_dff,           "dff" },
  98.      { "tff",   code_tff,           "tff" },
  99.      { "jkff",  code_jkff,          "jkff" },
  100.      { "tlatch",code_tlatch,    "tlatch"},
  101.      { "tglatch",code_tglatch,    "tglatch"}};
  102.  
  103. #define nr_of_elts(arr) ((int) (sizeof (arr)/sizeof (arr[0])))
  104. #define streq(s1,s2) (strcmp ((s1),(s2)) == 0)
  105.  
  106. /*
  107.    Die with errormessage
  108. */
  109. static void Die (s)
  110.  char *s;    
  111.     { fprintf (stderr, "%s\n", s);
  112.       exit (1);
  113.     };
  114.  
  115. /*
  116.    Check if we compile for the discrete timing model
  117. */
  118. static void check_if_dtm ()
  119.     { if (utm)
  120.          Die ("This atom can only coded in the discrete timing model\n");
  121.     };
  122.  
  123. /*
  124.    Name from symbol.
  125.    Because the macroexpander adds _<number> to every symbol
  126.    we must remove that suffix when recognizing atoms or source symbols
  127. */
  128. static char* name_from_symbol (s)
  129.  symbol s;
  130.     { char Buf[80];
  131.       char *name = symbolstr (s);
  132.       int ix;
  133.       for (ix = 0; ix < strlen (name) && !(name[ix] == '_'); ix++)
  134.          Buf [ix] = name [ix];
  135.       Buf [ix] ='\0';
  136.       return (new_string (Buf));
  137.     };
  138.  
  139. /*
  140.    Create an unique symbol
  141. */
  142. static int uniquenr = 0;
  143. static symbol unique_name ()
  144.     { char Buf[20];
  145.       sprintf (Buf, "gen_'_%d", uniquenr);
  146.       uniquenr++;
  147.       return (addsymbol (new_string (Buf)));
  148.     };
  149.  
  150. /*
  151.    Create a unique val of the given type
  152. */
  153. static val unique_val_of_type (org, t)
  154.  orig org;
  155.  typ t;
  156.     { switch (t -> tag)
  157.          { case TAGTypBase:
  158.           return (new_VSym (rdup_orig (org), unique_name ()));
  159.            case TAGTypProd:
  160.           { register int ix;
  161.             typ_list tl = t -> TypProd.ptypes;
  162.             val_list nvl = new_val_list ();
  163.             room_val_list (nvl, tl -> sz);
  164.             nvl -> sz = tl -> sz;
  165.             for (ix = 0; ix < tl -> sz; ix++)
  166.                nvl -> arr[ix] = unique_val_of_type (org, tl -> arr[ix]);
  167.             return (new_VList (nvl));
  168.           };
  169.            default: badtag (t -> tag);
  170.          };
  171.     };
  172.  
  173. /*
  174.    Give the formal connection parameters of a def
  175.    a procedure nr. We will need it to generate code.
  176. */
  177. static void prepare1_formcon (fc)
  178.  formcon fc;
  179.     { switch (fc -> tag)
  180.          { case TAGFCSym:
  181.           { setprior (fc -> FCSym.sym, procnr);
  182.             procnr++;
  183.           };
  184.           break;
  185.            case TAGFCList:
  186.           { register ix;
  187.             formcon_list fcl = fc -> FCList.l;
  188.             for (ix = 0; ix < fcl -> sz; ix++)
  189.                prepare1_formcon (fcl -> arr[ix]);
  190.           };
  191.           break;
  192.            default: badtag (fc -> tag);
  193.          };
  194.     };
  195.  
  196. /*
  197.    Find the type belonging to each 'fc'. Save also its original
  198.    name in the Glass text for user interface purposes.
  199.    Do also some consistency checks.
  200. */
  201. static void prepare2_formcon (fc,t)
  202.  formcon fc;
  203.  typ t;
  204.     { switch (fc -> tag)
  205.          { case TAGFCSym:
  206.           { symbol sy = fc -> FCSym.sym;
  207.             int nr = getprior (sy);
  208.             ctypes [nr - proclowend] = rdup_typ (t);
  209.             cnames [nr - proclowend] = name_from_symbol (sy);
  210.           };
  211.           break;
  212.            case TAGFCList:
  213.           { formcon_list fcl = fc -> FCList.l;
  214.             register int ix;
  215.             typ_list tl;
  216.             if (t -> tag != TAGTypProd)
  217.                Die ("type should be product type");
  218.             tl = t -> TypProd.ptypes;
  219.             if (fcl -> sz != tl -> sz)
  220.               Die ("formcon list and type list should have equal size");
  221.             for (ix=0; ix < fcl -> sz; ix++)
  222.                prepare2_formcon (fcl -> arr[ix], tl -> arr[ix]);
  223.               };
  224.           break;
  225.            default: badtag (fc -> tag);
  226.          };
  227.     };
  228.  
  229. /*
  230.    Prepare formal parameters of the definition
  231. */
  232. static void prepare_formcon (fc, t)
  233.  formcon fc;
  234.  typ t;
  235.     { int ix;
  236.       firstsrcnr = procnr;
  237.       prepare1_formcon (fc);
  238.       nrofinputs = procnr - firstsrcnr;
  239.       cnames = (char **) ckcalloc (procnr, sizeof (char *));
  240.       ctypes = (typ*) ckcalloc (procnr, sizeof (typ));
  241.       for (ix=0; ix < procnr; ix++) ctypes[ix] = typNIL;
  242.       prepare2_formcon (fc, t);
  243.     };
  244.  
  245. /* Given a symbol 's', search the context for a definition with
  246.  * that name, and return a pointer to it.
  247.  */
  248. static ctx_list context;
  249.  
  250. static int symbol_occurs_in (s, v)
  251.  symbol s;
  252.  val v;
  253.     { switch (v -> tag)
  254.          { case TAGVSym: return (v -> VSym.sym == s);
  255.            case TAGVList:
  256.           { val_list vl = v -> VList.l;
  257.             register int ix;
  258.             for (ix=0; ix < vl -> sz; ix++)
  259.                if (symbol_occurs_in (s, vl -> arr[ix])) return (1);
  260.             return (0);
  261.           };
  262.            default: badtag (v -> tag);
  263.          };
  264.     };
  265.           
  266. static def find_def (s)
  267.  symbol s;
  268.     { register unsigned int cix;
  269.       register unsigned int dix;
  270.  
  271.       for (cix = 0; cix < context -> sz; cix++)
  272.          { register def_list l = context -> arr[cix] -> defs;
  273.            for (dix = 0; dix < l -> sz; dix++)
  274.           { register def d = l -> arr[dix];
  275.             switch (d -> tag)
  276.                { case TAGDefAtom:
  277.                     if (d -> DefAtom.atnm == s) return (d);
  278.                     break;
  279.  
  280.                  case TAGDefBasetype:
  281.                     if (d -> DefBasetype.basename == s) return (d);
  282.                     break;
  283.  
  284.              case TAGDefVal:
  285.                 if (d -> DefVal.valnm == s) return (d);
  286.                     break;
  287.  
  288.              case TAGDefTyp:
  289.                     if (d -> DefTyp.typnm == s) return (d);
  290.                     break;
  291.  
  292.              case TAGDefCon:
  293.                 if (symbol_occurs_in (s, d -> DefCon.defcon))
  294.                    return (d);
  295.                 break;
  296.              case TAGDefConTr:
  297.                 if (symbol_occurs_in (s, d -> DefConTr.lhs))
  298.                    return (d);
  299.                 break;
  300.              default:
  301.                     badtag (d -> tag);
  302.                    };
  303.           };
  304.     }
  305.     return (defNIL);
  306.     };
  307.  
  308. /* Print usage of this program */
  309. static void usage (f)
  310.  FILE *f;
  311.      { fprintf (f, "Usage: dtm [-u] [-i] [-e] [-d<debugging flags>]\n");
  312.       fprintf (f, "-i: use implicit clock signals\n");
  313.       fprintf (f, "-u: use unit delay model\n");
  314.       fprintf (f, "-e: use eichelberger algebra\n");
  315.       helpdbflags (f, flagtab);
  316.     };
  317.  
  318. /* scan arguments and options */
  319. static void scanargs (argc, argv)
  320.  int argc;
  321.  char *argv[];
  322.     { int op;
  323.       argv++;
  324.       argc--;
  325.       while (argc>0)
  326.          { if (argv[0][0] != '-')
  327.           { fprintf (stderr, "too many arguments\n");
  328.             usage (stderr);
  329.             exit (1);
  330.           };
  331.            op = argv[0][1];
  332.            switch (op)
  333.          { case 'd': setdbflags (&argv[0][2], flagtab, TRUE);
  334.                  break;
  335.            case 'e': eich++;
  336.                  break;
  337.            case 'h':
  338.            case 'H': usage (stdout);
  339.                  exit (0);
  340.            case 'i': implicit++;
  341.                  break;
  342.            case 'o': showorig = FALSE;
  343.                  break;
  344.            case 'u': utm++;
  345.                  break;
  346.  
  347.            default: usage (stderr);
  348.                 exit (1);
  349.              };
  350.            argc--;
  351.            argv++;
  352.          };
  353.     };
  354.  
  355. static def find_thedef (dl)
  356.  def_list dl;
  357.     { register int ix;
  358.       register def d;
  359.       register def mdef = defNIL;
  360.       for (ix = 0; ix < dl -> sz; ix++)
  361.          { d = dl -> arr[ix];
  362.            if (d -> tag == TAGDefVal)
  363.           { if (mdef == defNIL)
  364.                { mdef = d;
  365.                }
  366.             else Die ("More than one codible definition found");
  367.           };
  368.          };
  369.       if (mdef == defNIL) Die ("No codible definition found");
  370.       return (mdef);
  371.     };
  372.  
  373. /*
  374.    value preparation:
  375.    The first pass of these rewrites flipflop applications.
  376.    The second pass splits where clauses where the left and right hand
  377.    side contain equally sized lists.
  378.    The third pass replaces DefCon parts by DefConTr parts in the syntax
  379.    tree so that the types of where part clauses can be deduced and
  380.    code may be generated.
  381. */
  382.  
  383. /*
  384.    prepare 1 val
  385.    rewrites flipflop applications
  386.    only the toplevel definitions must be stored on the context list
  387. */
  388. static val prepare1_val ();
  389. static char *type_error = "This description uses flipflops of the wrong type";
  390. static void check_flipflop_type (atnm, t)
  391.  char *atnm;
  392.  typ t;
  393.     { check_if_dtm ();
  394.       if (eich)
  395.          Die ("Eichelberger algebra may not be used for flipflops (yet)");
  396.       if (implicit && (streq (atnm, "tlatch") || streq (atnm, "tglatch")))
  397.          Die ("These flipflops do not have an implicit clock");
  398.       if (streq (atnm, "dff") ||
  399.           streq (atnm, "tff") ||
  400.           streq (atnm, "tlatch"))
  401.          { if (implicit)
  402.           { if (t -> tag != TAGTypBase) Die (type_error);
  403.           }
  404.            else 
  405.           { if (t -> tag != TAGTypProd) Die (type_error);
  406.             if (t -> TypProd.ptypes -> sz != 2) Die (type_error);
  407.           };
  408.          }
  409.       else
  410.          { if (t -> tag != TAGTypProd) Die (type_error);
  411.            if (implicit)
  412.           { if (t -> TypProd.ptypes -> sz != 2) Die (type_error);
  413.           }
  414.            else
  415.           { if (t -> TypProd.ptypes -> sz != 3) Die (type_error);
  416.           };
  417.          };
  418.     };
  419.  
  420. static val prepare_flipflop_application (v)
  421.  val v;
  422.     { orig org = v -> VAtom.atorig;
  423.       char *atomname = name_from_symbol (v -> VAtom.atnm);
  424.       def d = find_def (v -> VAtom.atnm);
  425.       typ atctyp = d -> DefAtom.atctyp;
  426.       typ uityp = atctyp -> TypUni.uityp;
  427.       typ uotyp = atctyp -> TypUni.uotyp;
  428.       val ival = unique_val_of_type (org, uityp);
  429.       val oval = unique_val_of_type (org, uotyp);
  430.       val natomappl = new_VAtom (rdup_orig (org),
  431.                 rdup_symbol (v -> VAtom.atnm),
  432.                 rdup_parval_list (v -> VAtom.atvpar),
  433.                 rdup_val (ival));
  434.       def_list wdefs = new_def_list ();
  435.       room_def_list (wdefs, 2);
  436.       check_flipflop_type (atomname, uityp);
  437.       wdefs -> sz = 2;
  438.       wdefs -> arr[0] = new_DefCon (rdup_orig (org), rdup_val (oval),
  439.                      natomappl);
  440.       wdefs -> arr[1] = new_DefCon (rdup_orig (org), ival, 
  441.                      prepare1_val (v -> VAtom.atcpar));
  442.       rfre_string (atomname);
  443.       return (new_VWhere (wdefs, oval));
  444.     };
  445.  
  446. static val prepare1_val (v)
  447.  val v;
  448.     { switch (v -> tag)
  449.          { case TAGVSym: return (rdup_val (v));
  450.            case TAGVList:
  451.           { register ix;
  452.             val_list vl = v -> VList.l;
  453.             val_list nvl = new_val_list ();
  454.             room_val_list (nvl, vl -> sz);
  455.             nvl -> sz = vl -> sz;
  456.             for (ix=0; ix < vl -> sz; ix++)
  457.                nvl -> arr [ix] = prepare1_val (vl -> arr[ix]);
  458.             return (new_VList (nvl));
  459.           };
  460.            case TAGVAtom:
  461.           { char *atnm = name_from_symbol (v -> VAtom.atnm);
  462.             if (streq (atnm, "jkff") ||
  463.             streq (atnm, "tff") ||
  464.             streq (atnm, "dff") ||
  465.             streq (atnm, "tlatch") ||
  466.             streq (atnm, "tglatch"))
  467.                { rfre_string (atnm);
  468.              return (prepare_flipflop_application (v));
  469.                };
  470.             rfre_string (atnm);
  471.             return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  472.                 rdup_symbol (v -> VAtom.atnm),
  473.                 rdup_parval_list (v -> VAtom.atvpar),
  474.                 prepare1_val (v -> VAtom.atcpar)));
  475.           };
  476.            case TAGVWhere:
  477.           { register int ix;
  478.             def_list dl = v -> VWhere.wdefs;
  479.             def_list ndl = new_def_list ();
  480.             room_def_list (ndl, dl -> sz);
  481.             ndl -> sz = dl -> sz;
  482.             for (ix = 0; ix < dl -> sz; ix++)
  483.                { register def d = dl -> arr [ix];
  484.              if (d -> tag != TAGDefCon)
  485.                 Die ("Only local connections allowed");
  486.              ndl -> arr [ix] =
  487.                 new_DefCon (rdup_orig (d -> DefCon.conorig),
  488.                     rdup_val (d -> DefCon.defcon),
  489.                      prepare1_val (d -> DefCon.conas));
  490.                };
  491.             return (new_VWhere (ndl, prepare1_val (v -> VWhere.wval)));
  492.           };
  493.            default: badtag (v -> tag);
  494.          };
  495.     };
  496.  
  497. /*
  498.    prepare 2 val: splits local definitions where left and right hand sides
  499.    are equally sized lists
  500. */
  501. static val prepare2_val ();
  502. static void try_split_vals (ndl, org, lhs, rhs)
  503.  def_list ndl;
  504.  orig org;
  505.  val lhs, rhs;
  506.     { val_list lvl, rvl;
  507.       int ix;
  508.       if ((lhs -> tag != TAGVList) || (rhs -> tag != TAGVList))
  509.          { app_def_list (ndl, new_DefCon (rdup_orig (org), rdup_val (lhs),
  510.                 prepare2_val (rhs)));
  511.            return;
  512.          };
  513.       lvl = lhs -> VList.l;
  514.       rvl = rhs -> VList.l;
  515.       if (lvl -> sz != rvl -> sz)
  516.          { app_def_list (ndl, new_DefCon (rdup_orig (org), rdup_val (lhs),
  517.                 prepare2_val (rhs)));
  518.            return;
  519.          };
  520.       for (ix = 0; ix < lvl -> sz; ix++)
  521.          try_split_vals (ndl, org, lvl -> arr[ix], rvl -> arr[ix]); 
  522.     };
  523.  
  524. static val prepare2_val (v)
  525.  val v;
  526.     { switch (v -> tag)
  527.          { case TAGVSym: return (rdup_val (v));
  528.            case TAGVList:
  529.           { register ix;
  530.             val_list vl = v -> VList.l;
  531.             val_list nvl = new_val_list ();
  532.             room_val_list (nvl, vl -> sz);
  533.             nvl -> sz = vl -> sz;
  534.             for (ix=0; ix < vl -> sz; ix++)
  535.                nvl -> arr [ix] = prepare2_val (vl -> arr[ix]);
  536.             return (new_VList (nvl));
  537.           };
  538.            case TAGVAtom: return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  539.                     rdup_symbol (v -> VAtom.atnm),
  540.                     rdup_parval_list (v -> VAtom.atvpar),
  541.                     prepare2_val (v -> VAtom.atcpar)));
  542.            case TAGVWhere:
  543.           { def_list dl = v -> VWhere.wdefs;
  544.             def_list ndl = new_def_list ();
  545.             int ix;
  546.             for (ix = 0; ix < dl -> sz; ix++)
  547.                { def d = dl -> arr[ix];
  548.              orig org = d -> DefCon.conorig;
  549.              val lhs = d -> DefCon.defcon;
  550.              val rhs = d -> DefCon.conas;
  551.              try_split_vals (ndl, org, lhs, rhs);
  552.                };
  553.             return (new_VWhere (ndl, prepare2_val (v -> VWhere.wval)));
  554.           };
  555.            default: badtag (v -> tag);
  556.          };
  557.     };
  558.  
  559. /*
  560.    prepare 3 val:
  561.    replaces DefCon's in the AST by DefConTr's for administrative purposes
  562.    (type deduction and code generation)
  563. */
  564. static val prepare3_val (v)
  565.  val v;
  566.     { switch (v -> tag)
  567.          { case TAGVSym: return (rdup_val (v));
  568.            case TAGVWhere:
  569.           { register ix;
  570.             def_list ndl = new_def_list ();
  571.             def_list dl = v -> VWhere.wdefs;
  572.             room_def_list (ndl, dl -> sz);
  573.             ndl -> sz = dl -> sz;
  574.             for (ix = 0; ix < dl -> sz; ix++)
  575.                { register def d = dl -> arr [ix];
  576.              int newprocnr = procnr;
  577.              procnr++;
  578.              ndl -> arr [ix] =
  579.                 new_DefConTr (rdup_orig (d -> DefCon.conorig),
  580.                     rdup_val (d -> DefCon.defcon),
  581.                     prepare3_val (d -> DefCon.conas),
  582.                     newprocnr);
  583.                };
  584.             return (new_VWhere (ndl, prepare3_val (v -> VWhere.wval)));
  585.           };
  586.            case TAGVList:
  587.           { register ix;
  588.             val_list vl = v -> VList.l;
  589.             val_list nvl = new_val_list ();
  590.             room_val_list (nvl, vl -> sz);
  591.             nvl -> sz = vl -> sz;
  592.             for (ix=0; ix < vl -> sz; ix++)
  593.                nvl -> arr [ix] = prepare3_val (vl -> arr[ix]);
  594.             return (new_VList (nvl));
  595.           };
  596.            case TAGVAtom:
  597.             return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  598.                     rdup_symbol (v -> VAtom.atnm),
  599.                     rdup_parval_list (v -> VAtom.atvpar),
  600.                     prepare3_val (v -> VAtom.atcpar)));
  601.            case TAGVLambda:
  602.            case TAGVSigma:
  603.            case TAGVApply:
  604.            case TAGVAppset:
  605.            case TAGVSyn:
  606.           Die ("Only wheres, atom applications, lists and symbols are allowed");
  607.            default: badtag (v -> tag);
  608.          };
  609.     };
  610.  
  611. /*
  612.    prepare types
  613. */
  614. static typ partial_build_typ (v, s, t)
  615.  val v;
  616.  symbol s;
  617.  typ t;
  618.     { switch (v -> tag)
  619.          { case TAGVSym:
  620.               { if (v -> VSym.sym == s) return (rdup_typ (t));
  621.             return (typNIL);
  622.           };
  623.            case TAGVList:
  624.           { register int ix;
  625.             val_list vl = v -> VList.l;
  626.             typ_list tl = new_typ_list ();
  627.             room_typ_list (tl, vl -> sz);
  628.             tl -> sz = vl -> sz;
  629.             for (ix=0; ix < vl -> sz; ix++)
  630.                tl -> arr[ix] = partial_build_typ (vl -> arr[ix], s, t);
  631.             return (new_TypProd (tl));
  632.           };
  633.            default: badtag (v -> tag);
  634.          };
  635.     };
  636.  
  637. /*
  638.    Unify types
  639. */
  640. static typ unify_types (t1,t2)
  641.  typ t1,t2;
  642.     { if (t1 == typNIL) return (rdup_typ (t2));
  643.       if (t2 == typNIL) return (rdup_typ (t1));
  644.       if (t1 -> tag != t2 -> tag) Die ("Can not unify types");
  645.       switch (t1 -> tag)
  646.          { case TAGTypBase: return (rdup_typ (t1));
  647.            case TAGTypProd:
  648.           { typ_list t1l = t1 -> TypProd.ptypes;
  649.             typ_list t2l = t2 -> TypProd.ptypes;
  650.             typ_list ntl = new_typ_list ();
  651.             register int ix;
  652.             if (t1l -> sz != t2l -> sz) Die ("Can not unify types");
  653.             room_typ_list (ntl, t1l -> sz);
  654.             ntl -> sz = t1l -> sz;
  655.             for (ix=0; ix < t1l -> sz; ix++)
  656.                ntl -> arr[ix] = unify_types (t1l -> arr[ix],
  657.                         t2l -> arr[ix]);
  658.             return (new_TypProd (ntl));
  659.           };
  660.            default: badtag (t1 -> tag);
  661.          };
  662.     };
  663.  
  664. static void update_type_in_def (d, t)
  665.  def d;
  666.  typ t;
  667.     { int nr = d -> DefConTr.nr - proclowend;
  668.       typ newtyp = unify_types (ctypes [nr], t);
  669.       rfre_typ (ctypes [nr]);
  670.       ctypes [nr] = newtyp;
  671.     };
  672.  
  673. static typ deduce_types_in_val ();
  674. static void deduce_types_in_def (d)
  675.  def d;
  676.     { int nr = d -> DefConTr.nr - proclowend;
  677.       typ t = deduce_types_in_val (d -> DefConTr.rhs, ctypes [nr]);
  678.       update_type_in_def (d,t);
  679.       rfre_typ (t);
  680.     };
  681.  
  682. static typ project_type (t, v, s)
  683.  typ t;
  684.  val v;
  685.  symbol s;
  686.     { if (t == typNIL) return (typNIL);
  687.       switch (v -> tag)
  688.          { case TAGVSym:
  689.           { if (v -> VSym.sym == s) return (rdup_typ (t));
  690.             return (typNIL);
  691.           };
  692.            case TAGVList:
  693.           { register int ix;
  694.             typ rettyp;
  695.             typ_list tl = t -> TypProd.ptypes;
  696.             val_list vl = v -> VList.l;
  697.             for (ix=0; ix < vl -> sz; ix++)
  698.                if ((rettyp = project_type (tl -> arr[ix],
  699.                     vl -> arr[ix], s)) != typNIL)
  700.               return (rettyp);
  701.             return (typNIL);
  702.           };
  703.            default: badtag (v -> tag);
  704.          };
  705.     };
  706.  
  707. static typ deduce_types_in_val (v,t)
  708.  val v;
  709.  typ t;
  710.     { switch (v -> tag)
  711.          { case TAGVSym:
  712.           { symbol sy = v -> VSym.sym;
  713.             def d;
  714.             int nr = getprior (sy);
  715.             if (nr >= firstsrcnr)
  716.                return (rdup_typ (ctypes [nr - proclowend]));
  717.             if ((d = find_def (sy)) == defNIL)
  718.                Die ("definition not found");
  719.             if (t != typNIL)
  720.                { typ parttyp = partial_build_typ
  721.                 (d -> DefConTr.lhs, sy, t);
  722.                  update_type_in_def (d, parttyp);
  723.              rfre_typ (parttyp);
  724.                };
  725.             nr = d -> DefConTr.nr;
  726.             return (project_type (ctypes[nr - proclowend],
  727.                 d -> DefConTr.lhs, sy));
  728.           };
  729.            case TAGVList:
  730.           { val_list vl = v -> VList.l;
  731.             typ_list gtl = typ_listNIL;
  732.             int ix;
  733.             typ_list ntl = new_typ_list ();
  734.             room_typ_list (ntl, vl -> sz);
  735.             ntl -> sz = vl -> sz;
  736.             if (t != typNIL)
  737.                { if ((t -> tag != TAGTypProd) ||
  738.                      (t -> TypProd.ptypes -> sz != vl -> sz))
  739.                     Die ("Mismatch between type and value");
  740.              gtl = rdup_typ_list (t -> TypProd.ptypes);
  741.                };
  742.             for (ix=0; ix < ntl -> sz; ix++)
  743.                ntl -> arr[ix] = deduce_types_in_val (vl -> arr[ix],
  744.                       (t==typNIL)?typNIL:gtl -> arr[ix]);
  745.             rfre_typ_list (gtl);
  746.             return (new_TypProd (ntl));
  747.           };
  748.            case TAGVAtom:
  749.           { symbol atnm = v -> VAtom.atnm;
  750.             def d = find_def (atnm);
  751.             typ dummy = deduce_types_in_val (v -> VAtom.atcpar,
  752.                     d -> DefAtom.atctyp -> TypUni.uityp);
  753.             rfre_typ (dummy);
  754.             return (rdup_typ (d -> DefAtom.atctyp -> TypUni.uotyp));
  755.           };
  756.            case TAGVWhere:
  757.           { typ dummy, rettyp;
  758.             typ srctyp = rdup_typ (t);    /* t may be overwritten */
  759.             def_list dl = v -> VWhere.wdefs;
  760.             int ix;
  761.             ins_ctx_list (context, 0, new_ctx (rdup_def_list (dl)));
  762.             if (t != typNIL)
  763.                dummy = deduce_types_in_val (v -> VWhere.wval, srctyp);
  764.             for (ix=0; ix < dl -> sz; ix++)
  765.                deduce_types_in_def (dl -> arr[ix]);
  766.             rettyp = deduce_types_in_val (v -> VWhere.wval, srctyp);
  767.             rfre_typ (dummy);
  768.             rfre_typ (srctyp);
  769.             del_ctx_list (context, 0);
  770.             return (rettyp);
  771.           };
  772.            default: badtag (v -> tag);
  773.          };
  774.     };
  775.  
  776. static void deduce_all_where_types ()
  777.     { typ dummy = deduce_types_in_val (defval, outtyp);
  778.       rfre_typ (dummy);
  779.     };
  780.  
  781. static int fully_defined (t)
  782.  typ t;
  783.     { switch (t -> tag)
  784.          { case TAGTypBase: return (1);
  785.            case TAGTypProd:
  786.           { typ_list tl = t -> TypProd.ptypes;
  787.             register int ix;
  788.             for (ix=0; ix < tl -> sz; ix++)
  789.                if (!fully_defined (tl -> arr[ix]))
  790.               return (0);
  791.             return (1);
  792.           };
  793.            default: badtag (t -> tag);
  794.          };
  795.     };
  796.  
  797. static void check_if_all_types_defined ()
  798.     { int ix;
  799.       for (ix=0; ix < procnr-proclowend; ix++)
  800.          if (!fully_defined (ctypes[ix]))
  801.         Die ("Not all types could be found");
  802.     };
  803.  
  804. static void add_all_types_to_cache (dl)
  805.  def_list dl;
  806.     { int ix;
  807.       for (ix = 0; ix < dl -> sz; ix++)
  808.          { def d = dl -> arr [ix];
  809.            if (d -> tag == TAGDefAtom)
  810.           { typ t = d -> DefAtom.atctyp;
  811.             add_to_cache (t -> TypUni.uityp);
  812.             add_to_cache (t -> TypUni.uotyp);
  813.           };
  814.          };
  815.       add_to_cache (intyp);
  816.       add_to_cache (outtyp);
  817.       for (ix = 0; ix < procnr - proclowend; ix++)
  818.          add_to_cache (ctypes [ix]);
  819.     };
  820.  
  821. static void prepare_types (dl)
  822.  def_list dl;
  823.     { deduce_all_where_types ();
  824.       check_if_all_types_defined ();
  825.       add_all_types_to_cache (dl);
  826.     }
  827.  
  828. static void prepare (dl)
  829.  def_list dl;
  830.     { def d;
  831.       val lambdaexp, pass1val, pass2val;
  832.       fprintf (stderr, "dtm: preparing...\n");
  833.       d = find_thedef (dl);
  834.       lambdaexp = d -> DefVal.valas;
  835.       intyp = rdup_typ (d -> DefVal.valtyp -> TypUni.uityp);
  836.       outtyp = rdup_typ (d -> DefVal.valtyp -> TypUni.uotyp);
  837.       deffc  = rdup_formcon (lambdaexp -> VLambda.lpar);
  838.       context = new_ctx_list ();
  839.       ins_ctx_list (context, 0, new_ctx (rdup_def_list (dl)));
  840.       pass1val = prepare1_val (lambdaexp -> VLambda.lval);
  841.       pass2val = prepare2_val (pass1val);
  842.       rfre_val (pass1val);
  843.       defval = prepare3_val (pass2val);
  844.       rfre_val (pass2val);
  845.       prepare_formcon (deffc, intyp);
  846.       prepare_types (dl);
  847.       rfre_ctx_list (context);
  848.     };
  849.  
  850. /*
  851.    code all the includes of the generated program
  852. */
  853. static void code_include_header (f)
  854.  FILE *f;
  855.     { fprintf (f, "#include <stdio.h>\n");
  856.       fprintf (f, "#include <X11/Intrinsic.h>\n");
  857.       fprintf (f, "#include <X11/StringDefs.h>\n");
  858.       fprintf (f, "#include <X11/cursorfont.h>\n");
  859.       fprintf (f, "#include <X11/Xaw/Form.h>\n");
  860.       fprintf (f, "#include <X11/Shell.h>\n");
  861.       fprintf (f, "#include <X11/Xaw/Paned.h>\n");
  862.       fprintf (f, "#include \"XtArgs.h\"\n");
  863.       fprintf (f, "#include \"Signalmgr.h\"\n");
  864.       fprintf (f, "#include \"Signal.h\"\n");
  865.       fprintf (f, "#include \"Command.h\"\n");
  866.       fprintf (f, "#include \"Toggle.h\"\n");
  867.       fprintf (f, "#include \"%sdtm_atoms.c\"\n", (eich)?"e":"");
  868.       fprintf (f, "\n");
  869.     };
  870.  
  871. /*
  872.    code initial declarations
  873. */
  874. static void code_initial_decls (f)
  875.  FILE *f;
  876.     { fprintf (f, "#define MaxLen 2000\n");
  877.     };
  878.  
  879. /*
  880.    code all forward procedure declarations
  881. */
  882. static void code_forward_procdec (f)
  883.  FILE *f;
  884.     { register int i;
  885.       for (i = proclowend; i < procnr; i++)
  886.          fprintf (f, "static void p%d ();\n", i);
  887.       fprintf (f, "static void sim ();\n\n");
  888.     };
  889.  
  890. /*
  891.    generate the declaration of a new local
  892. */
  893. static int code_new_local (f, t)
  894.  FILE *f;
  895.  typ t;
  896.     { int nr = localnr;
  897.       localnr++;
  898.       fprintf (f, "\t  ");
  899.       code_typ (f, t);
  900.       fprintf (f, " l%d;\n", nr);
  901.       return (nr);
  902.     };
  903.  
  904. static int code_new_int_local (f)
  905.  FILE *f;
  906.     { int nr = localnr;
  907.       localnr++;
  908.       fprintf (f, "\t  int l%d;\n", nr);
  909.       return (nr);
  910.     };
  911. /*
  912.    generate the code to declare the arguments of
  913.    a signal procedure and the opening brace
  914. */
  915. static void code_declareargs (f, t)
  916.  FILE *f;
  917.  typ t;
  918.     { fprintf (f, " ");
  919.       code_typ (f, t);
  920.       fprintf (f, " *p;\n int t;\n");
  921.     };
  922.  
  923. /*
  924.    generate the tail of a routine
  925. */
  926. static code_routinetail (f)
  927.  FILE *f;
  928.     { fprintf (f, "\t};\n\n");
  929.     };
  930.  
  931. /*
  932.    generate the code for the input signal procs
  933. */
  934. static void code_signal_proc (f, s, t)
  935.  FILE *f;
  936.  symbol s;
  937.  typ t;
  938.     { int nr = getprior (s);
  939.       fprintf (f, "/* input '%s' */\n", cnames [nr - proclowend]);
  940.       fprintf (f, "static ");
  941.       code_typ (f, t);
  942.       fprintf (f, " a%d [MaxLen];\n", nr);
  943.       fprintf (f, "static void p%d (p,t)\n", nr);
  944.       code_declareargs (f, t);
  945.       fprintf (f, "\t{ *p = a%d [t];\n", nr);
  946.       code_routinetail (f);
  947.     };
  948.  
  949. static void code_source_signals (f, fc, t)
  950.  FILE *f;
  951.  formcon fc;
  952.  typ t;
  953.     { switch (fc -> tag)
  954.          { case TAGFCSym:
  955.           code_signal_proc (f, fc -> FCSym.sym, t);
  956.           break;
  957.            case TAGFCList:
  958.           { formcon_list fcl = fc -> FCList.l;
  959.             typ_list tl = t -> TypProd.ptypes;
  960.             register int ix;
  961.             for (ix=0; ix < fcl -> sz; ix++)
  962.                code_source_signals (f, fcl -> arr[ix], tl -> arr[ix]);
  963.           };
  964.           break;
  965.            default: badtag (fc -> tag);
  966.          };
  967.     };
  968.  
  969. /*
  970.    generate code for the atoms
  971. */
  972. static void code_generic_zport (f, pnr, atnm, arg, t, ds, delay)
  973.  FILE *f;
  974.  int pnr;
  975.  char *atnm;
  976.  val arg;
  977.  typ t;
  978.  int ds;
  979.  int delay;
  980.     { sprintf (line_buffer, "\t  l%d = %s (t-%d);", ds, atnm, delay);
  981.       save_buffer ();
  982.     };
  983.  
  984. static void code_generic_uport (f, pnr, atnm, arg, t, ds, delay)
  985.  FILE *f;
  986.  int pnr;
  987.  char *atnm;
  988.  val arg;
  989.  typ t;
  990.  int ds;
  991.  int delay;
  992.     { char buf [80];
  993.       int ix, nr;
  994.       if (utm)
  995.          { sprintf (line_buffer, "\t  if (t-%d > 0){", delay);
  996.            save_buffer ();
  997.          };
  998.       nr = code_val (f, pnr, arg, t, (utm)?delay+1:delay);
  999.       sprintf (line_buffer, "\t  l%d = %s (l%d);", ds, atnm, nr);
  1000.       save_buffer ();
  1001.       if (utm)
  1002.          { sprintf (line_buffer, "\t  } else l%d = 0;", ds);
  1003.            save_buffer ();
  1004.          };
  1005.     };
  1006.  
  1007. static void code_generic_mport (f, pnr, atnm, arg, t, ds, delay)
  1008.  FILE *f;
  1009.  int pnr;
  1010.  char *atnm;
  1011.  val arg;
  1012.  typ t;
  1013.  int ds;
  1014.  int delay;
  1015.     { char buf [80];
  1016.       int ix, nr;
  1017.       typ_list tl = t -> TypProd.ptypes;
  1018.       if (utm)
  1019.          { sprintf (line_buffer, "\t  if (t-%d > 0){", delay);
  1020.            save_buffer ();
  1021.          };
  1022.       nr = code_val (f, pnr, arg, t, (utm)?delay+1:delay);
  1023.       sprintf (line_buffer, "\t  l%d = %s (", ds, atnm);
  1024.       for (ix = 0; ix < tl -> sz; ix++)
  1025.          { sprintf (buf, "l%d.f%d%s", nr, ix, (ix==tl->sz-1)?");":", ");
  1026.            strcat (line_buffer, buf);
  1027.          };
  1028.       save_buffer ();
  1029.       if (utm)
  1030.          { sprintf (line_buffer, "\t  } else l%d = 0;", ds);
  1031.            save_buffer ();
  1032.          };
  1033.     };
  1034.  
  1035. static void code_dff (f, pnr, atnm, arg, t, ds, delay)
  1036.  FILE *f;
  1037.  int pnr;
  1038.  char *atnm;
  1039.  val arg;
  1040.  typ t;
  1041.  int ds;
  1042.  int delay;
  1043.     { sprintf (line_buffer, "\t  if (t-%d > 0){", delay);
  1044.       save_buffer ();
  1045.       if (implicit)
  1046.          { int datanr = code_val (f, pnr, arg, t, delay+1);
  1047.            sprintf (line_buffer, "\t  l%d = l%d;", ds, datanr);
  1048.            save_buffer ();
  1049.          }
  1050.       else /* explicit clock signals */
  1051.          { val clock = arg -> VList.l -> arr[0];
  1052.            val data = arg -> VList.l -> arr[1];
  1053.            typ clocktyp = t -> TypProd.ptypes -> arr[0];
  1054.            typ datatyp =  t -> TypProd.ptypes -> arr[1];
  1055.            int cnr, cprevnr, prevqnr, datanr;
  1056.            cprevnr = code_val (f, pnr, clock, clocktyp, delay+1);
  1057.            cnr = code_val (f, pnr, clock, clocktyp, delay);
  1058.            sprintf (line_buffer, "\t  if ((l%d == 1) && (l%d == 0)){",
  1059.                     cnr, cprevnr);
  1060.            save_buffer ();
  1061.            datanr = code_val (f, pnr, data, datatyp, delay+1);
  1062.            sprintf (line_buffer, "\t  l%d = l%d;", ds, datanr);
  1063.            save_buffer ();
  1064.            sprintf (line_buffer, "\t  } else {");
  1065.            save_buffer ();
  1066.            prevqnr = code_new_int_local (f);
  1067.            sprintf (line_buffer, "\t  p%d (&l%d, t-%d);\n",
  1068.                 pnr, prevqnr, delay+1);
  1069.            save_buffer ();
  1070.            sprintf (line_buffer, "\t  l%d = l%d; };", ds, prevqnr);
  1071.            save_buffer ();
  1072.          };
  1073.       sprintf (line_buffer, "\t  } else l%d = 0;", ds);
  1074.       save_buffer ();
  1075.     };
  1076.  
  1077. static void code_tff (f, pnr, atnm, arg, t, ds, delay)
  1078.  FILE *f;
  1079.  int pnr;
  1080.  char *atnm;
  1081.  val arg;
  1082.  typ t;
  1083.  int ds;
  1084.  int delay;
  1085.     { char buf [80];
  1086.       int prevqnr;
  1087.       sprintf (line_buffer, "\t  if (t-%d > 0){", delay);
  1088.       save_buffer ();
  1089.       prevqnr = code_new_int_local (f);
  1090.       sprintf (line_buffer, "\t  p%d (&l%d, t-%d);\n",
  1091.             pnr, prevqnr, delay+1);
  1092.       save_buffer ();
  1093.       if (implicit)
  1094.          { int tnr = code_val (f, pnr, arg, t, delay+1);
  1095.            sprintf (line_buffer, "\t  l%d = (l%d)?not(l%d):l%d;",
  1096.             ds, tnr, prevqnr, prevqnr);
  1097.            save_buffer ();
  1098.          }
  1099.       else
  1100.          { val clock = arg -> VList.l -> arr [0];
  1101.            val tinput = arg -> VList.l -> arr [1];
  1102.            typ clocktyp = t -> TypProd.ptypes -> arr[0];
  1103.            typ tinputtyp = t -> TypProd.ptypes -> arr [1];
  1104.            int cprevnr = code_val (f, pnr, clock, clocktyp, delay+1);
  1105.            int cnr = code_val (f, pnr, clock, clocktyp, delay);
  1106.            int tnr;
  1107.            sprintf (line_buffer, "\t  if ((l%d == 1) && (l%d == 0)) {",
  1108.                 cprevnr, cnr);
  1109.            save_buffer ();
  1110.            tnr = code_val (f, pnr, tinput, tinputtyp, delay+1);
  1111.            sprintf (line_buffer, "\t  l%d = (l%d)?not(l%d):l%d; }",
  1112.             ds, tnr, prevqnr, prevqnr);
  1113.            save_buffer ();
  1114.            sprintf (line_buffer, "\t  else l%d = l%d;", ds, prevqnr);
  1115.            save_buffer ();
  1116.          };
  1117.       sprintf (line_buffer, "\t  } else l%d = 0;", ds);
  1118.       save_buffer ();
  1119.     };
  1120.  
  1121. static void code_jkff (f, pnr, atnm, arg, t, ds, delay)
  1122.  FILE *f;
  1123.  int pnr;
  1124.  char *atnm;
  1125.  val arg;
  1126.  typ t;
  1127.  int ds;
  1128.  int delay;
  1129.     { char buf [80];
  1130.       int ix, prevqnr;
  1131.       sprintf (line_buffer, "\t  if (t-%d > 0){", delay);
  1132.       save_buffer ();
  1133.       prevqnr = code_new_int_local (f);
  1134.       sprintf (line_buffer, "\t  p%d (&l%d, t-%d);\n",
  1135.             pnr, prevqnr, delay+1);
  1136.       save_buffer ();
  1137.       if (implicit)
  1138.          { int nr = code_val (f, pnr, arg, t, delay+1);
  1139.            sprintf (line_buffer,
  1140.             "\t  l%d = (l%d == 0)?(l%d.f0):(not(l%d.f1));\n",
  1141.             ds, prevqnr, nr, nr);
  1142.            save_buffer ();
  1143.          }
  1144.       else
  1145.          { val clock = arg -> VList.l -> arr[0];
  1146.            val jinput = arg -> VList.l -> arr[1];
  1147.            val kinput = arg -> VList.l -> arr[2];
  1148.            typ clocktyp = t -> TypProd.ptypes -> arr[0];
  1149.            typ jtyp = t -> TypProd.ptypes -> arr[1];
  1150.            typ ktyp = t -> TypProd.ptypes -> arr[2];
  1151.            int cprevnr = code_val (f, pnr, clock, clocktyp, delay+1);
  1152.            int cnr = code_val (f, pnr, clock, clocktyp, delay);
  1153.            int jnr,knr;
  1154.            sprintf (line_buffer, "\t  if ((l%d == 1) && (l%d == 0)) {",
  1155.                 cprevnr, cnr);
  1156.            save_buffer ();
  1157.            sprintf (line_buffer, "\t  if (l%d == 0) {", prevqnr);
  1158.            save_buffer ();
  1159.            jnr = code_val (f, pnr, jinput, jtyp, delay+1);
  1160.            sprintf (line_buffer, "\t  l%d = l%d; }", ds, jnr);
  1161.            save_buffer ();
  1162.            sprintf (line_buffer, "\t  else {");
  1163.            save_buffer ();
  1164.            knr = code_val (f, pnr, kinput, ktyp, delay+1);
  1165.            sprintf (line_buffer, "\t  l%d = not(l%d); }}", ds, knr);
  1166.            save_buffer ();
  1167.            sprintf (line_buffer, "\t  else l%d = l%d;", ds, prevqnr);
  1168.            save_buffer ();
  1169.          };
  1170.       sprintf (line_buffer, "\t  } else l%d = 0;", ds);
  1171.       save_buffer ();
  1172.     };
  1173.  
  1174. static void code_tlatch (f, pnr, atnm, arg, t, ds, delay)
  1175.  FILE *f;
  1176.  int pnr;
  1177.  char *atnm;
  1178.  val arg;
  1179.  typ t;
  1180.  int ds;
  1181.  int delay;
  1182.     { char buf [80];
  1183.       int ix, prevqnr, dnr, cnr;
  1184.       val clock = arg -> VList.l -> arr[0];
  1185.       val data = arg -> VList.l -> arr[1];
  1186.       typ clocktyp = t -> TypProd.ptypes -> arr[0];
  1187.       typ dtyp = t -> TypProd.ptypes -> arr[1];
  1188.       cnr = code_val (f, pnr, clock, clocktyp, delay);
  1189.       sprintf (line_buffer, "\t  if (l%d == 1){", cnr);
  1190.       save_buffer ();
  1191.       dnr = code_val (f, pnr, data, dtyp, delay);
  1192.       sprintf (line_buffer, "\t  l%d = l%d; }", ds, dnr);
  1193.       save_buffer ();
  1194.       sprintf (line_buffer, "\t  else if (t-%d == 0){", delay);
  1195.       save_buffer ();
  1196.       sprintf (line_buffer, "\t  l%d = 0; }", ds);
  1197.       save_buffer ();
  1198.       sprintf (line_buffer, "\t  else {");
  1199.       save_buffer ();
  1200.       prevqnr = code_new_int_local (f);
  1201.       sprintf (line_buffer, "\t  p%d (&l%d, t-%d);\n",
  1202.             pnr, prevqnr, delay+1);
  1203.       save_buffer ();
  1204.       sprintf (line_buffer, "\t  l%d = l%d; };", ds, prevqnr);
  1205.       save_buffer ();
  1206.     };
  1207.  
  1208. static void code_tglatch (f, pnr, atnm, arg, t, ds, delay)
  1209.  FILE *f;
  1210.  int pnr;
  1211.  char *atnm;
  1212.  val arg;
  1213.  typ t;
  1214.  int ds;
  1215.  int delay;
  1216.     { char buf [80];
  1217.       int ix, prevqnr, snr, sbnr, dnr;
  1218.       val s = arg -> VList.l -> arr[0];
  1219.       val sbar = arg -> VList.l -> arr[1];
  1220.       val data = arg -> VList.l -> arr[2];
  1221.       typ styp = t -> TypProd.ptypes -> arr[0];
  1222.       typ sbartyp = t -> TypProd.ptypes -> arr[1];
  1223.       typ dtyp = t -> TypProd.ptypes -> arr[2];
  1224.       snr = code_val (f, pnr, s, styp, delay);
  1225.       sbnr = code_val (f, pnr, sbar, sbartyp, delay);
  1226.       sprintf (line_buffer, "\t  if ((l%d == 1) && (l%d == 0)){",
  1227.                 snr, sbnr);
  1228.       save_buffer ();
  1229.       dnr = code_val (f, pnr, data, dtyp, delay);
  1230.       sprintf (line_buffer, "\t  l%d = l%d; }", ds, dnr);
  1231.       save_buffer ();
  1232.       sprintf (line_buffer, "\t  else if ((l%d == 1) || (l%d == 0)){",
  1233.                 snr, sbnr);
  1234.       save_buffer ();
  1235.       sprintf (line_buffer,
  1236.           "\t  fprintf (stderr, \"TG illegally clocked\\n\");");
  1237.       save_buffer ();
  1238.       sprintf (line_buffer, "\t  exit (1); }");
  1239.       save_buffer ();
  1240.       sprintf (line_buffer, "\t  else if (t-%d == 0){", delay);
  1241.       save_buffer ();
  1242.       sprintf (line_buffer, "\t  l%d = 0; }", ds);
  1243.       save_buffer ();
  1244.       sprintf (line_buffer, "\t  else {");
  1245.       save_buffer ();
  1246.       prevqnr = code_new_int_local (f);
  1247.       sprintf (line_buffer, "\t  p%d (&l%d, t-%d);\n",
  1248.             pnr, prevqnr, delay+1);
  1249.       save_buffer ();
  1250.       sprintf (line_buffer, "\t  l%d = l%d; };", ds, prevqnr);
  1251.       save_buffer ();
  1252.     };
  1253.  
  1254. /*
  1255.    generate code to select out of a lhs
  1256. */
  1257. static void code_project (v, s, suffix, lnr, l2nr)
  1258.  val v;
  1259.  symbol s;
  1260.  char *suffix;
  1261.  int lnr, l2nr;
  1262.     { switch (v -> tag)
  1263.          { case TAGVSym:
  1264.           if (v -> VSym.sym == s)
  1265.              { sprintf (line_buffer, "\t  l%d = l%d%s;", l2nr,
  1266.                     lnr, suffix);
  1267.                save_buffer ();
  1268.              };
  1269.           break;
  1270.            case TAGVList:
  1271.           { val_list vl = v -> VList.l;
  1272.             register int ix;
  1273.             char SBuf [40];
  1274.             for (ix = 0; ix < vl -> sz; ix++)
  1275.                { sprintf (SBuf, "%s.f%d", suffix, ix);
  1276.              code_project (vl -> arr[ix], s, SBuf, lnr, l2nr);
  1277.                };
  1278.           };
  1279.           break;
  1280.            default: badtag (v -> tag);
  1281.          };
  1282.     };
  1283.  
  1284. /*
  1285.    generate code for a value
  1286. */
  1287. static int code_val (f, pnr, v, t, delay)
  1288.  FILE *f;
  1289.  int pnr;
  1290.  val v;
  1291.  typ t;
  1292.  int delay;
  1293.     { switch (v -> tag)
  1294.          { case TAGVSym:
  1295.           { def d;
  1296.             int locnr;
  1297.             symbol sy = v -> VSym.sym;
  1298.             int prnr = getprior (sy);
  1299.             if (prnr < firstsrcnr)
  1300.                { d = find_def (sy);
  1301.              prnr = d -> DefConTr.nr;
  1302.                };
  1303.             locnr = code_new_local (f, ctypes [prnr - proclowend]);
  1304.             sprintf (line_buffer, "\t  p%d (&l%d, t-%d);",
  1305.                     prnr, locnr, delay);
  1306.             save_buffer ();
  1307.             if (prnr < firstsrcnr)
  1308.                { int loc2nr = code_new_local (f, t);
  1309.              code_project (d -> DefConTr.lhs, sy, "",
  1310.                     locnr, loc2nr);
  1311.              return (loc2nr);
  1312.                };
  1313.             return (locnr);
  1314.           };
  1315.            case TAGVWhere:
  1316.           { int locnr;
  1317.             def_list dl = v -> VWhere.wdefs;
  1318.             ins_ctx_list (context, 0, new_ctx (rdup_def_list (dl)));
  1319.             locnr = code_val (f, pnr, v -> VWhere.wval, t, delay);
  1320.             del_ctx_list (context, 0);
  1321.             return (locnr);
  1322.               };
  1323.            case TAGVList:
  1324.           { int nr = code_new_local (f, t);
  1325.             val_list vl = v -> VList.l;
  1326.             typ_list tl;
  1327.             int ix;
  1328.             if (t -> tag != TAGTypProd) Die ("type/val mismatch");
  1329.             tl = t -> TypProd.ptypes;
  1330.             if (vl -> sz != tl -> sz) Die ("size mismatch");
  1331.             for (ix=0; ix < vl -> sz; ix++)
  1332.                { int lnr = code_val (f, pnr, vl -> arr[ix],
  1333.                         tl -> arr[ix], delay);
  1334.              sprintf (line_buffer, "\t  l%d.f%d = l%d;",
  1335.                     nr, ix, lnr);
  1336.              save_buffer ();
  1337.                };
  1338.             return (nr);
  1339.           };
  1340.            case TAGVAtom:
  1341.           { int ix;
  1342.             int ds = code_new_local (f, t);
  1343.             char *atnm = name_from_symbol (v -> VAtom.atnm);
  1344.             def atdef = find_def (v -> VAtom.atnm);
  1345.             typ argtyp = atdef -> DefAtom.atctyp -> TypUni.uityp;
  1346.             for (ix = 0; ix < nr_of_elts (known_atoms); ix++)
  1347.                if (streq (atnm, known_atoms[ix].atomname))
  1348.               { /* nog geen system parameters voor atoms */
  1349.                 known_atoms [ix].atomcode
  1350.                 (f, pnr, known_atoms[ix].codedname,
  1351.                  v -> VAtom.atcpar, argtyp, ds, delay);
  1352.                 fre_string (atnm);
  1353.                 return (ds);
  1354.               };
  1355.             fprintf (stderr, "Unknown atom %s\n", atnm);
  1356.             exit (1);
  1357.           };
  1358.          };
  1359.     };
  1360.  
  1361. /*
  1362.    generate the widget structures
  1363. */
  1364. static void estab_widget_struct (f, t)
  1365.  FILE *f;
  1366.  typ t;
  1367.     { switch (t -> tag)
  1368.          { case TAGTypBase:
  1369.               fprintf (f, "Widget");
  1370.           break;
  1371.            case TAGTypProd:
  1372.           { typ_list tl = t -> TypProd.ptypes;
  1373.             int ix;
  1374.                 fprintf (f, "struct {");
  1375.             for (ix = 0; ix < tl -> sz; ix++)
  1376.                { estab_widget_struct (f, tl -> arr[ix]);
  1377.              fprintf (f, " w%d; ", ix);
  1378.                };
  1379.             fprintf (f, "}");
  1380.           };
  1381.           break;
  1382.            default: badtag (t -> tag);
  1383.          };
  1384.     };
  1385.  
  1386. static void code_widget_structs (f)
  1387.  FILE *f;
  1388.     { int nr;
  1389.       for (nr = firstsrcnr; nr < procnr; nr++)
  1390.          { estab_widget_struct (f, ctypes [nr - proclowend]);
  1391.            fprintf (f, " ws%d;\n\n", nr);
  1392.          }
  1393.       estab_widget_struct (f, outtyp);
  1394.       fprintf (f, " ows;\n\n");
  1395.     };
  1396.  
  1397. static void code_ini_widget_struct (f, ws, father, name, t, ed)
  1398.  FILE *f;
  1399.  char *ws;
  1400.  char *father;
  1401.  char *name;
  1402.  typ t;
  1403.  int ed;
  1404.     { switch (t -> tag)
  1405.          { case TAGTypBase:
  1406.           { fprintf (f,"\t  StartArgs;\n");
  1407.             fprintf (f,"\t  SetArg (XtNradioGroup, button);\n");
  1408.             fprintf (f,"\t  button = XtCreateManagedWidget (\"%s\",\n",
  1409.                 name);
  1410.             fprintf (f,"\t\ttoggleWidgetClass, %s, UseArgs);\n",
  1411.                 father);
  1412.             fprintf (f,"\t  StartArgs;\n");
  1413.             fprintf (f,"\t  SetArg (XtNlevels, %d);\n", (eich)?3:2);
  1414.             fprintf (f,"\t  SetArg (XtNtimeScale, 5);\n");
  1415.             fprintf (f,"\t  SetArg (XtNtimeDivision, 20);\n");
  1416.             fprintf (f,"\t  SetArg (XtNeditable, %d);\n", ed);
  1417.             fprintf (f,"\t  SetArg (XtNsample, init_sig);\n");
  1418.             fprintf (f,"\t  SetArg (XtNmaxSampleLength, MaxLen);\n");
  1419.             fprintf (f,"\t  SetArg (XtNsampleLength, XtNumber (init_sig));\n");
  1420.             fprintf (f,"\t  %s = XtCreateManagedWidget (\"signal\",\n",
  1421.                 ws);
  1422.             fprintf (f,"\t\tsignalWidgetClass, %s, UseArgs);\n",
  1423.                 father);
  1424.           };
  1425.           break;
  1426.            case TAGTypProd:
  1427.           { typ_list tl = t -> TypProd.ptypes;
  1428.             int ix;
  1429.             for (ix=0;ix < tl -> sz; ix++)
  1430.                { char Buf[80];
  1431.              char Name[80];
  1432.              typ t2 = tl -> arr[ix];
  1433.              sprintf (Buf, "%s.w%d", ws, ix);
  1434.              sprintf (Name, "%s.%d", name, ix);
  1435.                  code_ini_widget_struct (f, Buf, father, Name, t2, ed);
  1436.                };
  1437.           };
  1438.           break;
  1439.            default: badtag (t -> tag);
  1440.          };
  1441.     };
  1442.  
  1443. static void code_init_widget_structs (f)
  1444.  FILE *f;
  1445.     { int nr;
  1446.       char wsbuf[10];
  1447.       fprintf (f, "\t  button = NULL;\n");
  1448.       for (nr = firstsrcnr; nr < procnr; nr++)
  1449.          { sprintf (wsbuf, "ws%d", nr);
  1450.            code_ini_widget_struct (f, wsbuf, "inputs",
  1451.             cnames [nr-proclowend], ctypes [nr-proclowend], 1);
  1452.          };
  1453.       fprintf (f, "\t  button = NULL;\n");
  1454.       code_ini_widget_struct (f, "ows", "outputs", "o", outtyp, 0);
  1455.     };
  1456.  
  1457. /*
  1458.    generate code for a local definition
  1459. */
  1460. static void code_local_definition (f, d)
  1461.  FILE *f;
  1462.  def d;
  1463.     { int nr = d -> DefConTr.nr;
  1464.       int locnr;
  1465.       typ t = ctypes[nr-proclowend];
  1466.       fprintf (f, "/* local def */\n");
  1467.       fprintf (f, "static int b%d[MaxLen];\n", nr);
  1468.       fprintf (f, "static ");
  1469.       code_typ (f, t);
  1470.       fprintf (f, " a%d[MaxLen];\n", nr);
  1471.       fprintf (f, "static void p%d (p, t)\n", nr);
  1472.       code_declareargs (f, t);
  1473.       fprintf (f, "\t{\n");
  1474.       init_codebuffer (f);
  1475.       sprintf (line_buffer, "\t  if (b%d[t]) { *p = a%d[t]; }", nr, nr);
  1476.       save_buffer ();
  1477.       sprintf (line_buffer, "\t  else{");
  1478.       save_buffer ();
  1479.       locnr = code_val (f, nr, d -> DefConTr.rhs, t, 0);
  1480.       flush_codebuffer (f);
  1481.       fprintf (f, "\t  a%d[t] = l%d;\n", nr, locnr);
  1482.       fprintf (f, "\t  b%d[t] = 1;\n", nr);
  1483.       fprintf (f, "\t  *p = l%d; };\n", locnr);
  1484.       code_routinetail (f);
  1485.     };
  1486.  
  1487. /*
  1488.    generate code for the wheres
  1489. */
  1490. static void code_wheres (f, v)
  1491.  FILE *f;
  1492.  val v;
  1493.     { switch (v -> tag)
  1494.          { case TAGVSym:
  1495.           break;
  1496.            case TAGVList:
  1497.           { val_list vl = v -> VList.l;
  1498.             register int ix;
  1499.             for (ix=0; ix < vl -> sz; ix++)
  1500.                code_wheres (f, vl -> arr[ix]);
  1501.           };
  1502.           break;
  1503.            case TAGVAtom:
  1504.           code_wheres (f, v -> VAtom.atcpar);
  1505.           break;
  1506.            case TAGVWhere:
  1507.           { int ix;
  1508.             def_list dl = v -> VWhere.wdefs;
  1509.             ins_ctx_list (context, 0, new_ctx (rdup_def_list (dl)));
  1510.             code_wheres (f, v -> VWhere.wval);
  1511.             for (ix=0; ix < dl -> sz; ix++)
  1512.                code_wheres (f, dl -> arr[ix] -> DefConTr.rhs);
  1513.             for (ix=0; ix < dl -> sz; ix++)
  1514.                code_local_definition (f, dl -> arr[ix]);
  1515.             del_ctx_list (context, 0);
  1516.           };
  1517.           break;
  1518.            default: badtag (v -> tag);
  1519.          };
  1520.     };
  1521. /*
  1522.    generate code for the actual definition
  1523. */
  1524. static void code_sim (f)
  1525.  FILE *f;
  1526.     { int nr;
  1527.       fprintf (f, "static void sim (p,t)\n");
  1528.       code_declareargs (f, outtyp);
  1529.       fprintf (f, "\t{\n");
  1530.       init_codebuffer (f);
  1531.       nr = code_val (f, 0, defval, outtyp, 0);
  1532.       flush_codebuffer (f);
  1533.       fprintf (f, "\t  *p = l%d;\n", nr);
  1534.       code_routinetail (f);
  1535.     };
  1536.  
  1537. /*
  1538.    generate code to recompute output signals
  1539. */
  1540. static void code_connect_widget (f, nr, ws, suffix, t)
  1541.  FILE *f;
  1542.  int nr;
  1543.  char *ws;
  1544.  char *suffix;
  1545.  typ t;
  1546.     { switch (t -> tag)
  1547.          { case TAGTypBase:
  1548.           { fprintf (f, "\t  StartArgs;\n");
  1549.             fprintf (f, "\t  SetArg (XtNsample, &loc);\n");
  1550.             fprintf (f, "\t  SetArg (XtNsampleLength, &len);\n");
  1551.             fprintf (f, "\t  XtGetValues (%s, UseArgs);\n", ws);
  1552.             fprintf (f, "\t  max = (len<max)?max:len;\n");
  1553.             fprintf (f, "\t  for (i=0; i<MaxLen; i++)\n");
  1554.             fprintf (f, "\t     a%d [i]%s = (i<len)?loc[i]:0;\n",
  1555.                     nr, suffix);
  1556.           };
  1557.               break;
  1558.            case TAGTypProd:
  1559.           { typ_list tl = t -> TypProd.ptypes;
  1560.             int ix;
  1561.             for (ix=0; ix < tl -> sz; ix++)
  1562.                { char wsbuf[40];
  1563.              char sufbuf[40];
  1564.              sprintf (wsbuf, "%s.w%d", ws, ix);
  1565.              sprintf (sufbuf, "%s.f%d", suffix, ix);
  1566.              code_connect_widget (f, nr, wsbuf, sufbuf,
  1567.                         tl -> arr[ix]);
  1568.                };
  1569.           };
  1570.           break;
  1571.            default: badtag (t -> tag);
  1572.          };
  1573.     };
  1574.  
  1575. static void code_connect_output (f, ws, suffix, t)
  1576.  FILE *f;
  1577.  char *ws;
  1578.  char *suffix;
  1579.  typ t;
  1580.     { switch (t -> tag)
  1581.          { case TAGTypBase:
  1582.           { fprintf (f, "\t  for (i=0; i<max; i++)\n");
  1583.             fprintf (f, "\t     outarr[i] = out[i]%s;\n", suffix);
  1584.             fprintf (f, "\t  StartArgs;\n");
  1585.             fprintf (f, "\t  SetArg (XtNsampleLength, max);\n");
  1586.             fprintf (f, "\t  SetArg (XtNsample, outarr);\n");
  1587.             fprintf (f, "\t  XtSetValues (%s, UseArgs);\n", ws);
  1588.           };
  1589.           break;
  1590.            case TAGTypProd:
  1591.           { typ_list tl = t -> TypProd.ptypes;
  1592.             int ix;
  1593.             for (ix=0; ix < tl -> sz; ix++)
  1594.                { char wsbuf[40];
  1595.              char sufbuf[40];
  1596.              sprintf (wsbuf, "%s.w%d", ws, ix);
  1597.              sprintf (sufbuf, "%s.f%d", suffix, ix);
  1598.              code_connect_output (f, wsbuf, sufbuf, tl -> arr[ix]);
  1599.                };
  1600.           };
  1601.           break;
  1602.            default: badtag (t -> tag);
  1603.          };
  1604.     };
  1605.  
  1606. static void code_recompute (f)
  1607.  FILE *f;
  1608.     { int nr, ix;
  1609.       fprintf (f, "static void ReCompute ()\n");
  1610.       fprintf (f, "\t{ int *loc;\n");
  1611.       fprintf (f, "\t  int max=0;\n");
  1612.       fprintf (f, "\t  ");
  1613.       code_typ (f, outtyp);
  1614.       fprintf (f, " out[MaxLen];\n");
  1615.       fprintf (f, "\t  int outarr[MaxLen];\n");
  1616.       fprintf (f, "\t  int i, len;\n");
  1617.       for (nr = proclowend; nr < firstsrcnr; nr++)
  1618.          fprintf (f, "\t  for (i=0; i < MaxLen; i++) b%d [i] = 0;\n", nr);
  1619.       for (nr = firstsrcnr; nr < procnr; nr++)
  1620.          { char wsbuf[10];
  1621.            sprintf (wsbuf, "ws%d", nr);
  1622.            code_connect_widget (f, nr, wsbuf, "", ctypes[nr-proclowend]);
  1623.          };
  1624.       fprintf (f, "\t  for (i=0; i<max; i++)\n");
  1625.       fprintf (f, "\t     sim (&out[i], i);\n");
  1626.       code_connect_output (f, "ows", "", outtyp);
  1627.       code_routinetail (f);
  1628.     };
  1629.  
  1630. /*
  1631.    generate the main code
  1632. */
  1633. static void code_mainprogram (f)
  1634.  FILE *f;
  1635.     { fprintf (f,"#include \"DtmMain.c\"\n");
  1636.       code_init_widget_structs (f);
  1637.       fprintf (f,"\t  XtAddCallback (inputs, XtNoriginChanged, ");
  1638.       fprintf (f,"SignalmgrCallbackSetOrigin, outputs);\n");
  1639.       fprintf (f,"\t  XtAddCallback (outputs, XtNoriginChanged, ");
  1640.       fprintf (f,"SignalmgrCallbackSetOrigin, inputs);\n");
  1641.       fprintf (f,"\t  XtRealizeWidget (top);\n");
  1642.       fprintf (f,"\t  XtAppMainLoop (MyContext);\n");
  1643.       code_routinetail (f);
  1644.     };
  1645.  
  1646. /*
  1647.    code the program
  1648. */
  1649. static void code (f, dl)
  1650.  FILE *f;
  1651.     { fprintf (stderr, "dtm: coding...\n");
  1652.       context = new_ctx_list ();
  1653.       ins_ctx_list (context, 0, new_ctx (rdup_def_list (dl)));
  1654.       code_include_header (f);
  1655.       code_initial_decls (f);
  1656.       code_cached_types (f);
  1657.       code_forward_procdec (f);
  1658.       code_source_signals (f, deffc, intyp);
  1659.       code_wheres (f, defval);
  1660.       code_sim (f);
  1661.       code_widget_structs (f);
  1662.       code_recompute (f);
  1663.       code_mainprogram (f);
  1664.       rfre_ctx_list (context);
  1665.     };
  1666.  
  1667. /*
  1668.    Load all the definitions
  1669. */
  1670. static void load (f, dl)
  1671.  FILE *f;
  1672.  def_list *dl;
  1673.     { if (fscan_def_list (f, dl))
  1674.          { fprintf (stderr, "Read error: (%d): %s\n", tmlineno, tmerrmsg);
  1675.                exit (1);
  1676.          };
  1677.     };
  1678.  
  1679. main (argc, argv)
  1680.  int argc;
  1681.  char *argv [];
  1682.     { def_list all_defs;
  1683.       initsymbol ();
  1684.       scanargs (argc, argv);
  1685.       tmlineno = 1;
  1686.       load (infile, &all_defs);
  1687.       prepare (all_defs);
  1688.       code (outfile, all_defs);
  1689.       if (stat)
  1690.          { int ix;
  1691.            rfre_def_list (all_defs);
  1692.            rfre_formcon (deffc);
  1693.            rfre_val (defval);
  1694.            rfre_typ (intyp);
  1695.            rfre_typ (outtyp);
  1696.            for (ix=0; ix < procnr - proclowend; ix++)
  1697.           rfre_typ (ctypes[ix]);
  1698.            flush_cached_types ();
  1699.            flushsymbol ();
  1700.            stat_ds (stderr);
  1701.            stat_string (stderr);
  1702.          };
  1703.     }
  1704.